module Salsa.Types where
import Control.Monad.Error
import IO
import Text.ParserCombinators.Parsec
import qualified Data.HashTable as Hash
import System.FilePath

-----------------------------------
-- Environment and Scope Definitions
-----------------------------------
data Env = Link SymbolTable Scope
data Scope = Scope Env | Nil
type SymbolTable = Hash.HashTable String Exp

updateEnv :: Env -> String -> Exp -> IO Bool
updateEnv env = Hash.update $ getST env

lookupEnv :: Env -> String -> IO (Maybe Exp)
lookupEnv env = Hash.lookup $ getST env

insertEnv :: Env -> String -> Exp -> IO ()
insertEnv env = Hash.insert $ getST env

getST :: Env -> SymbolTable
getST (Link st  _) = st

nextEnv :: Env -> Scope
nextEnv (Link _ s) = s

nullEnv :: IO Env 
nullEnv = do st <- newST
             return $ Link st Nil

newEnv :: Env -> IO Env
newEnv from = do st <- newST
                 return $ Link st (Scope from)

newST :: IO SymbolTable
newST = (Hash.new (==) Hash.hashString) 

-----------------------------------
-- Salsa Expressions Definition
-----------------------------------
data Exp  = Symbol String
          | Integer Integer
          | String String
          | List [Exp]
          | DotList [Exp] Exp
          | Bool Bool
          | Primitive ([Exp] -> ThrowsError Exp)
          | Lambda Exp [Exp] Env
          | IOFun ([Exp] -> IOThrowsError Exp)
          | Port Handle
instance Show Exp where show = showExp

isFalse :: Exp -> Bool
isFalse (Bool False) = True
isFalse x = False

isSymbol (Symbol _) = True
isSymbol other = False

showExp :: Exp -> String
showExp (Symbol sym) = sym
showExp (Integer int) = show int
showExp (String str) = show str
showExp (Bool True)   = "#t"
showExp (Bool False)  = "#f"
showExp (List [Symbol "lambda", formals,body]) = "(lambda " ++ show formals ++ " ...)"
showExp (List l)      = showL l
showExp (DotList head tail) = "(" ++ (unwords . map show) head ++ " . " ++ show tail ++ ")"
showExp (Primitive _) = "<primitive procedure>"
showExp (Lambda args body _) = "(lambda " ++ (show args) ++ " ...)"
showExp (IOFun _) = "<IO primitive>"
showExp (Port _) = "<IO port>"


showL :: [Exp] -> String
showL l  = "(" ++ (unwords . map show) l  ++ ")"

unwordsList :: [Exp] -> String
unwordsList = unwords . map show

appendList :: Exp -> Exp -> Exp
appendList (List a) (List b) = List (a ++ b)

------------------------------------------------
-- Lambda and function definition helpers
------------------------------------------------

isFun :: Exp -> Bool
isFun (Lambda _ _ _) = True
isFun (Primitive _) = True
isFun (IOFun _) = True
isFun other = False

-- Takes an expression that represents a function definition 
-- and transforms it to an expression that represents a 
-- symbol definition mapped to a lambda procedure
fd2sd :: Exp -> Env -> ThrowsError Exp
fd2sd def@(List ((Symbol "define"):lambdaList:rest)) env =
    case split def of 
      Left err -> throwError err
      Right (List sd) -> return $ List [Symbol "define", name sd, Lambda (formals sd) (body sd) env]
    where split :: Exp -> ThrowsError Exp
          split def@(List ((Symbol "define"):lambdaList:rest)) =
              if null rest 
              then throwError $ BadSpecialForm "Unrecognized special form. Expecting a function body in: " def
              else case funNameAndFormals lambdaList of
                     Left err -> throwError err
                     Right (List [name,formals]) -> return $ List $ [name,formals] ++ rest
          name = (!! 0)
          formals = (!! 1)
          body = (drop 2)

funNameAndFormals :: Exp -> ThrowsError Exp
funNameAndFormals lambdaList = 
    case funName lambdaList of 
      Left err -> throwError err
      Right name -> case funFormals lambdaList of 
                      Left err -> throwError err
                      Right formals -> do return $ List [name,formals]

funName :: Exp -> ThrowsError Exp
funName (DotList (f@(Symbol _):_) _) = return f   -- (f formals* . arg)
funName (List (f@(Symbol _):_)) = return f  -- (f formals*) 
funName other = throwError $ BadSpecialForm "Unrecognized Special form expecting a lambda list, found:" other 

funFormals :: Exp -> ThrowsError Exp
funFormals (DotList ((Symbol _):formals) dotTail) = return $ DotList formals dotTail -- (f formals* . arg)
funFormals (List ((Symbol _):formals)) = return $ List formals -- (f formals*)
funFormals other = throwError $ BadSpecialForm "Unrecognized special form expecting a lambda list, found:" other

validFormals (DotList head (Symbol _)) = areSymbols head
validFormals (List l) = areSymbols l
validFormals (Symbol _) = True
validFormals other = False

areSymbols = and . map isSymbol

-----------------------------------
-- Error Definitions
-----------------------------------
data SalsaError = NumArgs Integer [Exp] String
                | AtLeastNumArgs Integer [Exp] String
                | TypeMismatch String Exp String
                | BadSpecialForm String Exp
                | NotFunction String String
                | UnboundVar String String
                | Parser ParseError
                | UnexpectedEOF String Int String
                | Default String
                | BadMerengue
                | MamboError String
instance Show SalsaError where show = showError
type ThrowsError = Either SalsaError
type IOThrowsError = ErrorT SalsaError IO

instance Error SalsaError where
    noMsg = Default "An error has occurred"
    strMsg = Default

showError :: SalsaError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (Parser perr) = "Parse error at " ++ show perr
showError (NumArgs expected found name) = "Expected " ++ show expected 
                                     ++ " args; found values " ++ (unwordsList found) ++ " in form: " ++ name
showError (AtLeastNumArgs expected found name) = "Expected at least " ++ show expected 
                                     ++ " args; found values " ++ (unwordsList found) ++ " in form: " ++ name
showError (TypeMismatch expected found name) = "Invalid type: expected " ++ expected 
                                          ++ ", found " ++ show found ++ " in procedure " ++ name
showError (BadMerengue) = "Invalid Merengue file"
showError (MamboError msg ) = "Error while processing a Mambo file: " ++ msg
showError (UnexpectedEOF name line str) = "Unexpected end of file " ++ name ++ " at line " ++ (show line) ++ ". Last read attempt: " ++ str

liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val

trapError action failing = action `catchError` failing

showIOThrows :: IOThrowsError String -> IO String
showIOThrows action = runErrorT (action `trapError` (return . show)) >>= return . extractValue

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

--------------------------------------
-- Used to be Celia Code
--------------------------------------
data Tag = Spill | Serve

isMambo name = (takeExtension name) == ".mrn"
isMerengue name = (takeExtension name) == ".mbo"

